Ham Radio 2000 #1/Ham Radio 2000.iso/ham2000/packet/p_aa4re/bb212src/bbmisc.pas

Pascal/Delphi Source File | 1991-12-11 | 15.2 KB | 567 lines

(*===========================================================================*)
(* Miscellaneous things - 1                                                  *)
(*                                                                           *)
(*   Copyright 1988, 1989, 1990, 1991 by H. Roy Engehausen.  All rights      *)
(*   reserved.                                                               *)
(*                                                                           *)
(*===========================================================================*)

{$O+}

UNIT BBMISC;

INTERFACE

USES
  bbdummy;

  FUNCTION  check_priv(uc_to_check : user_class_type) : BOOLEAN;

  FUNCTION  find_port_addr (look_port_char : CHAR) : port_block_ptr;

  FUNCTION  find_port (look_port_char : CHAR) : BOOLEAN;

  FUNCTION  compare_call(c1 : bb_addr_str; c2 : bb_addr_str) : BOOLEAN;

  FUNCTION  strip_ssid  (c : bb_addr_str) : bb_addr_str;

  PROCEDURE process_sid (in_str : str_ptr);

  FUNCTION  file_test   (in_file : file_name_str) : INTEGER;

  PROCEDURE connect_format(in_str : str_ptr; this_port : port_block_ptr);

  PROCEDURE set_dollar1_parm (in_str : str_ptr);

  FUNCTION  move_array_to_str(array_ptr    : POINTER;
                              array_length : BYTE) : STRING;

  PROCEDURE set_binary_switch(switch_value : BOOLEAN);

  PROCEDURE switch_show(b: BOOLEAN);

  FUNCTION comment_line(VAR s: STRING) : BOOLEAN;

IMPLEMENTATION

  USES
    DOS,
    bbmdata,
    bbmem,
    bbmess,
    bbmisc2,
    bbsema2,
    bbstr;

(*===========================================================================*)
(* Compare user's privilege against some things                              *)
(*===========================================================================*)

FUNCTION check_priv(uc_to_check : user_class_type) : BOOLEAN;

  BEGIN;

    WITH active_tcb^.uid_data DO
      check_priv := (user_class >= uc_to_check)
                                        OR ((user_flag AND user_f_sysop) <> 0);

  END;

(*===========================================================================*)
(* Find the port that corresponds to a letter.                               *)
(*===========================================================================*)

FUNCTION  find_port_addr (look_port_char : CHAR) : port_block_ptr;

  VAR
    look_port : port_block_ptr;

  BEGIN;

    look_port := ring_port;

    REPEAT

      IF look_port^.port_char = look_port_char THEN
        BEGIN;
          find_port_addr := look_port;
          EXIT;
        END;

      look_port := look_port^.next_port;

    UNTIL look_port = ring_port;

    find_port_addr := NIL;


  END;



(*===========================================================================*)
(* Find the port that corresponds to a letter.  Set active port              *)
(*===========================================================================*)

FUNCTION find_port (look_port_char : CHAR) : BOOLEAN;

  VAR
    look_port : port_block_ptr;

  BEGIN;

    look_port := find_port_addr(look_port_char);

    find_port := look_port <> NIL;

    IF look_port <> NIL THEN
      BEGIN;
        active_tcb^.tcb_port := look_port;
        active_port          := look_port;
        find_port := TRUE;
      END
    ELSE
      find_port := FALSE;

  END;

(*===========================================================================*)
(* Compare two callsigns dropping the ssid                                   *)
(*===========================================================================*)

FUNCTION compare_call(c1 : bb_addr_str; c2 : bb_addr_str) : BOOLEAN;

{$UNDEF DEBUG_CC}

  VAR
    i : BYTE;
    j : BYTE;

  BEGIN;

    i := LENGTH(c1);
    IF i > LENGTH(c2) THEN
      i := LENGTH(c2);

{$IFDEF DEBUG_CC}
WRITELN('I=', i);
{$ENDIF}

    compare_call := TRUE;

    j := 0;
    WHILE j < i DO
      BEGIN;
        INC(j);
        IF (c1[j] = '-') AND (c2[j] = '-') THEN
          EXIT;
        IF c1[j] <> c2[j] THEN
          BEGIN;
            compare_call := FALSE;
            EXIT;
          END;
      END;

{$IFDEF DEBUG_CC}
WRITELN('Out of loop');
{$ENDIF}

    IF LENGTH(c1) = LENGTH(c2) THEN
      EXIT;

{$IFDEF DEBUG_CC}
WRITELN('Test 1 fail -- ', i, ' -- ', j);
{$ENDIF}

    INC(j);

    IF (LENGTH(c1) = i) AND (c2[j] = '-') THEN
      EXIT;

{$IFDEF DEBUG_CC}
WRITELN('Test 2 failed');
{$ENDIF}

    IF c1[j] = '-' THEN
      EXIT;

{$IFDEF DEBUG_CC}
WRITELN('Test 3 failed');
{$ENDIF}

    compare_call := FALSE;

  END;

(*===========================================================================*)
(* Strip SSID                                                                *)
(*===========================================================================*)

FUNCTION strip_ssid(c : bb_addr_str) : bb_addr_str;

  VAR
    i : BYTE;
    j : BYTE;

  BEGIN;

    i := POS('-', c);
    IF i > 0 THEN DEC(i);
    strip_ssid := substr(c, 1, i);

  END;

(*===========================================================================*)
(* Handle SID                                                                *)
(*===========================================================================*)

PROCEDURE process_sid(in_str : str_ptr);

  TYPE
    t = ^BYTE;

  VAR
    i : BYTE;

  (*=========================================================================*)
  (* Get a level of a certain character                                      *)
  (*=========================================================================*)

  PROCEDURE get_level(type_char   : CHAR;
                      byte_to_set : t;
                      max_level   : BYTE);

    VAR
      i : BYTE;

    BEGIN;

      (*---------------------------------------------------------------------*)
      (* See if character exists.  If not, we are done                       *)
      (*---------------------------------------------------------------------*)

      i := POS(type_char, in_str^);

      IF i = 0 THEN
        BEGIN;
          byte_to_set^ := 0;
          EXIT;
        END;

      (*---------------------------------------------------------------------*)
      (* Get the character to test                                           *)
      (*---------------------------------------------------------------------*)

      type_char := in_str^[i+1];

      (*---------------------------------------------------------------------*)
      (* If non-numeric then this is TYPE=1                                  *)
      (*---------------------------------------------------------------------*)

      IF (type_char < '0') OR (type_char > '9') THEN
        BEGIN;
          byte_to_set^ := 1;
          EXIT;
        END;

      (*---------------------------------------------------------------------*)
      (* Set level.  There is a MAX                                          *)
      (*---------------------------------------------------------------------*)

      i := 1 + ORD(type_char) - ORD('0');

      IF i > max_level THEN
        i := max_level;

      byte_to_set^ := i;

    END; (*----- End of GET_LEVEL subroutine --------------------------------*)

  (*=========================================================================*)
  (* Main line of process SID                                                *)
  (*=========================================================================*)

  BEGIN;

    (*-----------------------------------------------------------------------*)
    (* Handle the sign on for an advanced bbs                                *)
    (*      This is an incoming command for the following format:            *)
    (*          [xxxxxxx-fff]                                                *)
    (*      xxxxxx = the author id and version #                             *)
    (*      fff    = features of this BBS                                    *)
    (*                    $ = BID                                            *)
    (*                    R = Improved BID responses                         *)
    (*                    M = MID                                            *)
    (*                    C = Clock set                                      *)
    (*                    H = Hierarchical address                           *)
    (*-----------------------------------------------------------------------*)

    (*-----------------------------------------------------------------------*)
    (* Advanced BBS -- Set proper bits                                       *)
    (*-----------------------------------------------------------------------*)

    active_tcb^.tcb_abbs := TRUE;

    (*-----------------------------------------------------------------------*)
    (* Strip the author/version info from the string                         *)
    (*-----------------------------------------------------------------------*)

    i := POS('-', in_str^);
    WHILE i <> 0 DO
      BEGIN;
        in_str^ := substr(in_str^, i+1, 0);
        i := POS('-', in_str^);
      END;

    (*-----------------------------------------------------------------------*)
    (* Set the switches for the features as appropriate                      *)
    (*-----------------------------------------------------------------------*)

    IF POS('M', in_str^) <> 0 THEN
      active_tcb^.tcb_mids_ok := TRUE;

    IF POS('H', in_str^) <> 0 THEN
      active_tcb^.tcb_h_ok := TRUE;

    get_level('R', @i, 2);

    IF (i > 0) OR (POS('$', in_str^) <> 0) THEN
      INC(i);

    active_tcb^.tcb_bid_level := i;

  END;

(*===========================================================================*)
(* Test to see if a file exists                                              *)
(*===========================================================================*)

FUNCTION  file_test (in_file : file_name_str) : INTEGER;

  VAR
    f : FILE;
    i : INTEGER;

  BEGIN;

    {$I-}
    CLOSE(f);
    i := IORESULT;
    {$I+}

    ASSIGN(f, in_file);

    {$I-}
    RESET(f);
    i := IORESULT;
    {$I+}

    file_test := i;

    {$I-}
    CLOSE(f);
    i := IORESULT;
    {$I+}

  END;

(*===========================================================================*)
(* Either adds or subtracts the VIA and PC*PA port                           *)
(*===========================================================================*)

PROCEDURE connect_format(in_str : str_ptr; this_port : port_block_ptr);

  VAR
    i : WORD;
    s : STRING[12];

  (*=========================================================================*)
  (* Subprogram for VIA                                                      *)
  (*=========================================================================*)

  PROCEDURE handle_via;

    VAR
      p_type : port_type_type;

    BEGIN;

      p_type := this_port^.port_type;

      s := 'V';
      i := find(in_str, @s);

      s := 'VIA';
      IF i = 0 THEN
        i := find(in_str, @s);

      IF i = 1 THEN
        i := 0;

      IF (i > 0) THEN
        BEGIN;
          IF (p_type = port_g8bpq) OR (p_type = port_aeapk232) THEN
            EXIT;
          in_str^ := subword(in_str, 1, i-1) + ' ' + subword(in_str, i+1, 0);
          EXIT;
        END;

      IF (p_type <> port_g8bpq) AND (p_type <> port_aeapk232) THEN
        EXIT;

      i := 2;

      IF (substr(in_str^, 1, 2) = 'CO') AND
             (in_str^[3] <> ' ') THEN
        i := 1;

      IF in_str^[1] <> 'C' THEN
        i := 1;

      IF words(in_str^) > i THEN
        in_str^ := subword(in_str, 1, i) + ' VIA ' + subword(in_str, i+1, 0);

    END; (*----- End via procedure ------------------------------------------*)

  (*=========================================================================*)
  (* Subprogram for PC*PA                                                    *)
  (*=========================================================================*)

  PROCEDURE handle_pcpa;
    BEGIN;

      IF (LENGTH(in_str^) > 1) AND (in_str^[2] <> ' ') THEN
        in_str^ := in_str^[1] + ' ' + substr(in_str^, 2, 0);

      s := subword(in_str, 2, 1);

      IF (LENGTH(s) < 2) OR (s[2] <> ':') THEN
        s := '0:' + s;

      s[1] := this_port^.port_num;

      in_str^ := subword(in_str, 1, 1) + ' ' + s +  ' ' + subword(in_str, 3, 0);

    END;

  BEGIN;

    handle_via;

    IF this_port^.port_type = port_pcpa THEN
      handle_pcpa;

  END;

(*===========================================================================*)
(* Sets error parameter                                                      *)
(*===========================================================================*)

PROCEDURE set_dollar1_parm(in_str : str_ptr);

  VAR
    here : POINTER;
    i    : WORD;

  BEGIN;

    free_task_mem('$1', TRUE);

    i := LENGTH(in_str^) + 1;
    here := get_task_mem('$1', i);
    MOVE(in_str^, here^, i);

  END;

(*===========================================================================*)
(* Move character array to string                                            *)
(*===========================================================================*)

FUNCTION move_array_to_str(array_ptr    : POINTER;
                           array_length : BYTE) : STRING;

  TYPE
    in_array = ARRAY[1..255] OF CHAR;

  VAR
    i : WORD;
    o : STRING;
    p : ^in_array;

  BEGIN;

    i := 1;
    p := array_ptr;

    WHILE TRUE DO
      IF (i > array_length) OR (p^[i] = ' ') THEN
        BEGIN;
           DEC(i);
           IF i > 0 THEN
             MOVE(p^, o[1], i);
           o[0] := CHR(i);
           move_array_to_str := o;
           EXIT;
        END
      ELSE
        INC(i);

  END;

(*===========================================================================*)
(* Set thread's binary switch                                                *)
(*===========================================================================*)

PROCEDURE set_binary_switch(switch_value : BOOLEAN);
  VAR
    p : tcb_ptr;

  BEGIN;
    active_tcb^.tcb_binary := switch_value;
    p := active_tcb^.conv_tcb;
    IF p <> NIL THEN
      p^.tcb_binary := switch_value;
  END;

(*===========================================================================*)
(* Show a switch setting                                                     *)
(*===========================================================================*)

PROCEDURE switch_show(b: BOOLEAN);
  BEGIN;

    IF b THEN
      send_message(message_sw_on)
    ELSE
      send_message(message_sw_off);

  END;

(*===========================================================================*)
(* Determine if comments                                                     *)
(*===========================================================================*)

FUNCTION comment_line(VAR s: STRING) : BOOLEAN;

  VAR
    i : BYTE;
    j : INTEGER;

  BEGIN;

    i := 1;
    j := LENGTH(s);

    WHILE (i <= j) AND (s[i] = ' ') DO
      INC(i);

    IF (i > j) OR (s[i] = ';') THEN
      comment_line := TRUE
    ELSE
      comment_line := FALSE;

    EXIT;

  END;
END.